perm filename EXPR.SAI[PNT,HE]30 blob
sn#559062 filedate 1981-01-24 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00014 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 ENTRY
C00005 00003 ! miscellaneous definitions
C00010 00004 ! expression builders: exp,bfact,bterm,aexp,term,factor,pfactor
C00018 00005 ! expression builders: hash,hashindex,new_expr,check_expr,!!expr1,!!expr2,!!expr3
C00021 00006 ! expression builders: opcode, idcode, cncode,incode,arcode,prcode
C00034 00007 ! strcode,vmcode
C00039 00008 ! mkexpr,gtexpr,aref,idref,pref
C00043 00009 ! buffer definitions, ipush,fpush,gpush,ppush,cpush
C00045 00010 ! αexpr$,βexpr$,nexpr,expr$11,expr$2,expr$off
C00051 00011 ! $append,$aappend
C00055 00012 ! $$gtidref,$$gtanyexp,$$gtexpr,$$gtvexpr
C00058 00013 ! $$gtxp2
C00059 00014 END "EXPR"
C00060 ENDMK
C⊗;
ENTRY;
BEGIN "EXPR"
DEFINE $$PRGID=TRUE; DEFINE $EXPR=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
REQUIRE "[][]" DELIMITERS;
DEFINE TOKEN_INDEX = [TOKENINDEX],TOKEN_CLASS=[tokenclass],ID_CLASS=[TOKEN_INDEX];
REAL PROCEDURE SIMPLIFY(INTEGER OP;REAL F1,F2);
BEGIN "simplifies binary operations on scalar constants "
INTEGER I1,I2,B1,B2; REAL F3;
I1←F1; I2←F2;
B1←IF F1 THEN 1 ELSE 0;
B2←IF F2 THEN 1 ELSE 0;
CASE OP OF
BEGIN
REDEFINE ZZ(ARG0,ARG1,ARG2,EX)=[;];
REDEFINE ZZC(ARG0,ARG1,ARG2,EX)=[;EX];
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[];
OP_LIST
END;
RETURN(F3);
END;
REDEFINE ZZ(ACR0,ARG1,ARG2,EX)=[FALSE,];
REDEFINE ZZC(ARG0,ARG1,ARG2,EX)=[TRUE,];
preload_array(COMPILEEXPRESSION, OP_LIST,BOOLEAN, 1, #PNTINTOPS);
! will be moved to SYMBOL;
RPTR(EXPR$)PROCEDURE MK_EXPR$;
BEGIN
RPTR(EXPR$)EE;
EE←NEW_RECORD(EXPR$);
if !debug and ¬!!debugging then EXPR$:DBEXPR[ee]←NEW_RECORD(DBEXPR);
RETURN(EE);
END;
BOOLEAN RETURN_NULL;
! miscellaneous definitions ;
PRELOAD_WITH "SCALAR","VECTOR","ROT","TRANS","FRAME","EVENT","STRING";
STRING ARRAY DTYPES[1:7];
COMMENT TEMPORARY EXPR RECORD USED INTERNALLY BY THESE ROUTINES;
RCLASS !!EXPR(INTEGER OP,X1,X2; INTEGER TYPE,#EL; RPTR(!!EXPR)SON,BRO;
BOOLEAN CONST; REAL RLVAL; RPTR(EXPR$)EXPR$);
! OP is opcode, x1,x2 are used to represent floating point numbers in 11 format
x1 along is used for index of array
x2 is used for leveloffset of array
const is true if the value is a constant
expr$ is used (particularly in QUERY) to store record EXPR$;
INTEGER ##EL;
INTEGER BRCHAR,SPBR;
REDEFINE ZZ(ARG0,ARG1,ARG2)=[ARG0,] ;
REDEFINE ZZC(ARG0,ARG1,ARG2)=[ARG0,] ;
preload_array(CODE_OP, OP_LIST,STRING, 1, #PNTINTOPS);
REDEFINE ZZ(ARG0,ARG1,ARG2)=[ARG2,];
REDEFINE ZZC(ARG0,ARG1,ARG2)=[ARG2,];
preload_array(CODE_LEVEL,OP_LIST,INTEGER,1,#PNTINTOPS);
REDEFINE XXCOUNT=0;
REDEFINE ZZ(ARG1,ARG2,ARG3)=[];
REDEFINE ZZC(ARG1,ARG2,ARG3)=[];
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[
REDEFINE XXCOUNT=XXCOUNT + 1;];
OP_LIST;
DEFINE XXARG=0;
REDEFINE ZZ(ARG1,ARG2,ARG3)=[ REDEFINE XXARG=XXARG + 1;];
REDEFINE ZZC(ARG1,ARG2,ARG3)=[ REDEFINE XXARG=XXARG + 1;];
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[
REDEFINE XXVAL = ((((XXARG*#DTYPE)+ARG1)*#DTYPE+ARG2)*#DTYPE+ARG3);
XXVAL,
];
DEFINE #HASHTAB=XXCOUNT;
preload_array(HASHTAB, OP_LIST, INTEGER, 1, #HASHTAB);
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,AR2,ARG)=[
IFCR ¬DECLARATION(ARGNAME) THENC
REQUIRE "UNDEFINED OP:: "&CVPS(ARGNAME)&"
" MESSAGE;
ENDC];
OP_LIST;
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[
IFCR ¬DECLARATION(ARGNAME) THENC
MAKEOP(ARGNAME)
ENDC ARGNAME,];
preload_array(PCODE, OP_LIST, INTEGER, 1, #HASHTAB);
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[ARGNDX,];
preload_array(PCODENDX, OP_LIST, INTEGER, 1, #HASHTAB);
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[ARGTYPE,];
preload_array(OPTYPE, OP_LIST, INTEGER, 1, #HASHTAB);
PROCEDURE GGTOKEN(BOOLEAN FLAG(TRUE));
α INTEGER I;
GTOKEN(FLAG);
FOR I←1 STEP 1 UNTIL #PNTINTOPS
DO IF EQU(TOKEN,CODE_OP[I])
THEN BEGIN
#TOKEN←OPERATOR_TYPE;
TOKEN_CLASS←CODE_LEVEL[I];
TOKEN_INDEX←I;
RETURN;
END;
IF EQU(TOKEN,0) THEN #TOKEN←UNDECLARED_TYPE;
β;
FORWARD RPTR (!!EXPR) PROCEDURE OPCODE(INTEGER OP,NARGS; RPTR(!!EXPR)EPTR;
RPTR(EXPR$)EEPTR(NULL_RECORD));
FORWARD RPTR (!!EXPR) PROCEDURE CNCODE(REAL VAL);
FORWARD RPTR (!!EXPR) PROCEDURE INCODE(INTEGER VAL);
FORWARD RPTR (!!EXPR) PROCEDURE IDCODE(RPTR(SYMBOL)SYMPTR);
FORWARD RECURSIVE RPTR (!!EXPR) PROCEDURE ARCODE(RPTR(SYMBOL)PTR;INTEGER OPERATION(XGTVAL));
FORWARD RECURSIVE RPTR(!!EXPR)PROCEDURE VPRCODE(RPTR(SYMBOL)PRSYM);
FORWARD RPTR(!!EXPR)PROCEDURE STRCODE(STRING S; INTEGER FIRSTNUM(XPUSHQI));
FORWARD RPTR (!!EXPR) PROCEDURE VMCODE;
! expression builders: exp,bfact,bterm,aexp,term,factor,pfactor;
! EXP E: BF { OR BF }
BFACT BF: BT { AND BT }
BTERM BT: AE | AE <REL> AE
AEXP AE: {+|-} T {+|- T }
TERM T: F {*|/ F}
FACTOR F: PF or PF↑PF
PFACTOR PF: ( E ) or | E | or func(E,E,E,..) or <constant> or <id> or ¬ PF;
DEFINE EXP= [XXXXX(EXP_XX)];
! FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE EXP XXXXX(EXP_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE BEFACT XXXXX(BEFACT_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE BFACT XXXXX(BFACT_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE BTERM XXXXX(BTERM_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE AEXP XXXXX(AEXP_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE TERM XXXXX(TERM_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE FACTOR XXXXX(FACTOR_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE PF XXXXX(PF_XX);
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE XXXXX(INTEGER LEVEL);
RECURSIVE RPTR(!!EXPR) PROCEDURE OP1(INTEGER LVL);
α INTEGER I; I←TOKEN_INDEX; GGTOKEN;
RETURN(OPCODE(I,1,XXXXX(LVL)));
β;
RECURSIVE RPTR(!!EXPR)PROCEDURE OP2(INTEGER LVL;RPTR(!!EXPR)E);
α INTEGER I; I←TOKEN_INDEX; GGTOKEN;
!!EXPR:BRO[E]←XXXXX(LVL);
RETURN(OPCODE(I,2,E));
β;
RECURSIVE RPTR(!!EXPR) PROCEDURE XXXXX(INTEGER LEVEL);
α RPTR(!!EXPR)$$1,$$2,$$3; INTEGER I,I2;
CASE LEVEL OF
α
[BEFACT_XX] [BFACT_XX] [AEXP_XX] [TERM_XX]
α
IF LEVEL=AEXP_XX AND #TOKEN=OPERATOR_TYPE
AND TOKEN_CLASS= AEXP_XX
THEN $$1←OP1(LEVEL + 1)
ELSE $$1←XXXXX(LEVEL+1);
WHILE #TOKEN=OPERATOR_TYPE AND TOKEN_CLASS=LEVEL DO
$$1←OP2(LEVEL+1,$$1);
β;
[EXP_XX] [BTERM_XX] [FACTOR_XX]
α
$$1←XXXXX(LEVEL + 1);
IF (#TOKEN=OPERATOR_TYPE OR #TOKEN=RES_TYPE) AND TOKEN_CLASS=LEVEL
THEN $$1←OP2(LEVEL+1,$$1);
β;
[PF_XX]
CASE #TOKEN OF
α "CASE #TOKEN"
[REAL_TYPE]
α INTEGER I;
$$1←CNCODE(REALSCAN(TOKEN,I)); GGTOKEN(FALSE); β;
[INT_TYPE]
α INTEGER I;
$$1←INCODE(INTSCAN(TOKEN,I)); GGTOKEN(FALSE); β;
[ID_TYPE]
α CASE SYMBOL:ACCESS[TOKENPTR] OF
α
[#SIMPLE] $$1←IDCODE(TOKENPTR);
[#ARRAY] $$1←ARCODE(TOKENPTR);
[#PROCEDURE] $$1←VPRCODE(TOKENPTR)
β;
GGTOKEN(FALSE);
β ;
[OPERATOR_TYPE]
CASE TOKEN_INDEX OF
α "CASE TOKEN_INDEX"
[LPAREN_X]
α "LPAREN_X"
GGTOKEN; $$2←$$1←EXP; I2←1;
IF TOKEN≠")"
THEN WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP;
I2←I2+1;
$$2←(!!EXPR:BRO[$$2]←$$3);
β;
IF TOKEN≠")" THEN
ERROR("MISMATCHED PAREN")
ELSE GGTOKEN(FALSE);
IF I2≠1 THEN $$1←OPCODE(IMPLICIT_X,I2,$$1);
β "LPAREN_X";
[MAGNITUDE_X]
α GGTOKEN; $$1←EXP;
IF TOKEN="|"
THEN GGTOKEN(FALSE)
ELSE ERROR("MISMATCHED VERT BAR");
$$1←OPCODE(MAGNITUDE_X,1,$$1);
β;
[STOS_X][DOWNARROW_X][DOLLAR_X][ALPHA_X][NOT_X]
$$1←OP1(EXP_XX);
[INSCALAR_X]
α
$$1←OPCODE(TOKEN_INDEX,0,NULL_RECORD);
GGTOKEN(FALSE);
β;
[VM_X] IF CURPROC THEN $$1←VMCODE
ELSE ERROR("VM can only be called in a procedure body");
[QQUERY_X]
α
$$1←OPCODE(TOKEN_INDEX,0,NULL_RECORD,PRINTCODE);
GGTOKEN(FALSE);
β;
ELSE IF TOKEN=DQUOTE THEN
α "string constant found"
READTILL(dquote);
$$1←STRCODE(TOKEN);
GGTOKEN(FALSE);
β "string constant found"
ELSE
α I←TOKEN_INDEX; IF TOKEN_CLASS≠LEVEL
THEN ERROR(TOKEN&" is not a valid term in an expression");
IF I=RUNTIME_X THEN
α GGTOKEN(FALSE);
IF TOKEN≠"(" THEN RETURN($$1←OPCODE(I,1,CNCODE(0.0)))
ELSE STOKEN←TRUE;
β;
WORD_READ("(");
GGTOKEN;
$$2←$$1←EXP; I2←1;
WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP; I2←I2 + 1;
$$2←(!!EXPR:BRO[$$2]←$$3);
β;
IF TOKEN≠")" THEN ERROR("MISMATCHED PAREN") ELSE GGTOKEN(FALSE);
$$1←OPCODE(I,I2,$$1);
β
β "CASE TOKEN_INDEX";
[RES_TYPE]
α I←TOKEN_INDEX;
IF TOKEN_CLASS=LEVEL
THEN
α WORD_READ("("); GGTOKEN;
$$2←$$1←EXP; I2←1;
WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP; I2←I2 + 1;
$$2←(!!EXPR:BRO[$$2]←$$3);
β;
IF TOKEN≠")"
THEN ERROR("MISMATCHED PAREN")
ELSE GGTOKEN(FALSE);
$$1←OPCODE(I,I2,$$1);
β
ELSE IF RETURN_NULL THEN $$1←NULL_RECORD
ELSE ERROR(TOKEN&" is not a valid term in an expression");
β;
ELSE IF TOKEN=DQUOTE THEN
α "string constant found"
READTILL(dquote);
$$1←STRCODE(TOKEN);
GGTOKEN(FALSE);
β "string constant found"
ELSE
α
IF RETURN_NULL THEN $$1←NULL_RECORD
ELSE ERROR("UNEXPECTED TOKEN FOUND ⊂"&TOKEN&"⊃");
β
β "CASE #TOKEN"
β;
RETURN($$1);
β;
! expression builders: hash,hashindex,new_expr,check_expr,!!expr1,!!expr2,!!expr3;
INTEGER PROCEDURE HASH(INTEGER OP; INTEGER ARRAY IX);
RETURN((((OP*#DTYPE + IX[1])*#DTYPE+IX[2])*#DTYPE +IX[3]));
INTEGER PROCEDURE HASHINDEX(INTEGER HASHVAL);
BEGIN
INTEGER INDEX,LB,UB;
LB←1;UB←#HASHTAB;
DO BEGIN
INDEX←(LB+UB)/2;
IF HASHTAB[INDEX]=HASHVAL THEN RETURN(INDEX)
ELSE IF HASHTAB[INDEX]>HASHVAL THEN UB←INDEX-1
ELSE LB←INDEX+1;
END UNTIL LB>UB;
RETURN(0);
END;
RPTR (!!EXPR) PROCEDURE NEW_EXPR(INTEGER OP; RPTR(!!EXPR) SON(NULL_RECORD),
BRO(NULL_RECORD),SELF(NULL_RECORD));
BEGIN
RPTR (!!EXPR) CUR;
IF SELF=NULL_RECORD THEN CUR←NEW_RECORD(!!EXPR) ELSE CUR←SELF;
!!EXPR:OP[CUR]←OP;
!!EXPR:SON[CUR]←SON;
!!EXPR:BRO[CUR]←BRO;
##EL←##EL + (!!EXPR:#EL[CUR]←1);
RETURN(CUR);
END;
INTEGER PROCEDURE CHECK_EXPR(INTEGER OP,NARGS; RPTR(!!EXPR)ARRAY EXPRRY);
BEGIN
COMMENT EXPPRY WILL BE OF SIZE [1:NARGS];
INTEGER I;
INTEGER ARRAY IX[1:3];
IF NARGS>3 THEN ERROR("More arguments for function "&CODE_OP[OP]&" than allowed");
ARRCLR(IX);
FOR I←1 STEP 1 UNTIL NARGS DO IX[I]←!!EXPR:TYPE[EXPRRY[I]];
I←HASHINDEX(HASH(OP,IX));
RETURN(I);
END;
RPTR(!!EXPR)PROCEDURE !!EXPRM(INTEGER NARGS,OP,X1(0),X2(0));
BEGIN RPTR(!!EXPR) R1;
R1←NEW_RECORD(!!EXPR);
##EL←##EL+(!!EXPR:#EL[R1]←NARGS);
!!EXPR:OP[R1]←OP;
!!EXPR:X1[R1]←X1;
!!EXPR:X2[R1]←X2;
END;
! expression builders: opcode, idcode, cncode,incode,arcode,prcode;
RPTR (!!EXPR) PROCEDURE OPCODE(INTEGER OP,NARGS; RPTR(!!EXPR)EPTR;
RPTR(EXPR$)EEPTR(NULL_RECORD));
BEGIN
RPTR(!!EXPR)ARRAY EXPRRY[0:NARGS]; ! 0 in case NARGS=0 ;
RPTR(!!EXPR) P1,P2;
INTEGER I;INTEGER PCODE_INDEX;
P1←EPTR;
FOR I←1 STEP 1 UNTIL NARGS DO
BEGIN
EXPRRY[I]←P1;
P1←!!EXPR:BRO[P1];
END;
IF P1≠NULL_RECORD THEN ERROR("P1 should be null record");
IF (PCODE_INDEX←CHECK_EXPR(OP,NARGS,EXPRRY))=0
THEN BEGIN
STRING S; S←NULL;
FOR I←1 STEP 1 UNTIL NARGS DO
S←S&" "&DTYPES[!!EXPR:TYPE[EXPRRY[I]]]&",";
ERROR("operator/function "&CODE_OP[OP]&" cannot take operand(s)"&S[1 to ∞-1]);
END;
IF NOT !NOFOLD AND COMPILEEXPRESSION[OP] THEN
BEGIN "constant folding"
IF NARGS=2 AND OPTYPE[PCODE_INDEX]=#SC AND
!!EXPR:CONST[EXPRRY[1]] AND !!EXPR:CONST[EXPRRY[2]]
THEN BEGIN "constant arguments"
REAL R;
##EL←##EL-!!EXPR:#EL[EXPRRY[1]]-!!EXPR:#EL[EXPRRY[2]];
R←SIMPLIFY(OP,!!EXPR:RLVAL[EXPRRY[1]],!!EXPR:RLVAL[EXPRRY[2]]);
P1←CNCODE(R);
RETURN(P1);
END
ELSE IF NARGS=1 AND OPTYPE[PCODE_INDEX]=#SC AND !!EXPR:CONST[EXPRRY[1]]
THEN BEGIN
REAL R;
##EL←##EL-!!EXPR:#EL[EXPRRY[1]];
R←SIMPLIFY(OP,0.0,!!EXPR:RLVAL[EXPRRY[1]]);
P1←CNCODE(R);
RETURN(P1);
END;
END;
P1←NEW_RECORD(!!EXPR);
IF PCODENDX[PCODE_INDEX]
THEN BEGIN I←2; !!EXPR:X1[P1]←PCODENDX[PCODE_INDEX]; END
ELSE I←1;
##EL←##EL + (!!EXPR:#EL[P1]←I);
!!EXPR:OP[P1]←PCODE[PCODE_INDEX];
!!EXPR:TYPE[P1]←OPTYPE[PCODE_INDEX];
!!EXPR:SON[P1]←EPTR;
IF (!!EXPR:EXPR$[P1]←EEPTR) THEN ##EL←##EL+EXPR$:#BODY[EEPTR];
RETURN(P1);
END;
RPTR (!!EXPR) PROCEDURE CNCODE(REAL VAL);
BEGIN "cncode"
COMMENT CODE TO HANDLE CONSTANTS;
RPTR(!!EXPR)E1; INTEGER I1,I2;
FLTOUT(VAL,I1,I2);
E1←!!EXPRM(3,XPUSHSCI,I1,I2);
!!EXPR:TYPE[E1]←#SC;
!!EXPR:CONST[E1]←TRUE;
!!EXPR:RLVAL[E1]←VAL;
RETURN(E1);
END "cncode";
RPTR (!!EXPR) PROCEDURE INCODE(INTEGER VAL);
BEGIN "incode"
COMMENT CODE TO HANDLE CONSTANTS;
RPTR(!!EXPR)E1;
E1←!!EXPRM(2,XPUSHINTI,VAL);
!!EXPR:TYPE[E1]←#SC;
!!EXPR:CONST[E1]←TRUE;
!!EXPR:RLVAL[E1]←VAL;
RETURN(E1);
END "incode";
RPTR (!!EXPR) PROCEDURE IDCODE(RPTR(SYMBOL)SYMPTR);
BEGIN ! COMMENT CHANGE ID_OFFSET PART WHEN WE CAN DETERMINE ID_OFFSET DIRECTLY;
RPTR(!!EXPR)E1;
IF SYMBOL:INDEX[SYMPTR]>0 THEN
E1←!!EXPRM(3,XAGTVAL,SYMBOL:INDEX[SYMPTR],SYMBOL:OFFSET[SYMPTR])
ELSE
E1←!!EXPRM(2,XGTVAL,SYMBOL:OFFSET[SYMPTR]);
!!EXPR:TYPE[E1]←SYMBOL:TYPE[SYMPTR];
RETURN(E1);
END;
RPTR(!!EXPR)PROCEDURE IDNDXCODE(RPTR(SYMBOL)PTR);
IF SYMBOL:INDEX[PTR]>0
THEN BEGIN RPTR(!!EXPR) E1;
E1←!!EXPRM(2,XPUSHINTI,SYMBOL:INDEX[PTR]);
RETURN(E1);
END
ELSE RETURN(NEW_EXPR(XNOOP));
RECURSIVE RPTR(!!EXPR)PROCEDURE ARNDXCODE(RPTR(SYMBOL)PTR);
BEGIN
! This procedure produces the tree form for the array
reference index. To get the full array reference
use arcode with the right argument GTVAL or CHNGE;
RPTR(!!EXPR)E2,E3;
INTEGER I;
GGTOKEN;
IF TOKEN≠"[" THEN ERROR("Need [ after array name");
GGTOKEN;
E2←EXP;
IF (E2=NULL_RECORD) OR (!!EXPR:TYPE[E2]≠#SC)
THEN ERROR("Index of Array must be scalar");
FOR I←2 STEP 1 UNTIL ARRAYREC:#DIM[SYMBOL:OBJECT[PTR]] DO
BEGIN
IF TOKEN≠"," THEN ERROR("Need comma between fields of array index");
GTOKEN;
IF ((E3←EXP)=NULL_RECORD) OR (!!EXPR:TYPE[E3]≠#SC)
THEN ERROR("Index of Array must be scalar");
!!EXPR:BRO[E3]←E2;
E2←E3;
END;
IF TOKEN≠"]" THEN ERROR("Need ] for bounds of array");
RETURN(E2);
END;
RECURSIVE RPTR(!!EXPR)PROCEDURE ARCODE(RPTR(SYMBOL)PTR; INTEGER OPERATION(XGTVAL));
BEGIN
RPTR(!!EXPR)E1;
IF (OPERATION≠XGTVAL) AND (OPERATION≠XCHNGE)
THEN ERROR("Error in ARCODE, OPERATION can take only XGTVAL or XCHNGE");
E1←!!EXPRM(2,OPERATION,SYMBOL:OFFSET[PTR]);
!!EXPR:TYPE[E1]←SYMBOL:TYPE[PTR];
!!EXPR:SON[E1]←ARNDXCODE(PTR);
RETURN(E1);
END;
RPTR(!!EXPR)PROCEDURE SPRCODE(RPTR(SYMBOL)PRSYM);
BEGIN
RPTR(!!EXPR)E1;
E1←!!EXPRM(2,XPROC,SYMBOL:OFFSET[PRSYM]);
RETURN(E1);
END;
RECURSIVE RPTR(!!EXPR)PROCEDURE PRCODE(RPTR(SYMBOL)PRSYM);
BEGIN "prcode"
INTEGER NARGS; RPTR(PROC)P;
RPTR(!!EXPR)EF;
NARGS←PROC:NARGS[P←SYMBOL:OBJECT[PRSYM]];
IF NARGS =0 THEN EF←SPRCODE(PRSYM)
ELSE BEGIN "procedure with arguments"
! E1,ETOP1 are pointers to the procedure call,
E0 refers to the arguments set up if they are values ;
RPTR(!!EXPR)E0,E1,ETOP1,ETMP,ETMP2; INTEGER I;
GGTOKEN;
IF TOKEN≠"(" THEN
BEGIN STRING S; INTEGER J; S←NULL;
IF (J←PROC:NON_DEFAULT_ARGS[P])>0
THEN ERROR("Need at least "&cvs(J)&" non-default parameters");
FOR J←1 STEP 1 UNTIL NARGS DO
S←S&","&PROC:DEFAULT_ARG[P][J];
$CLNSAVE←$CLNSAVE[1 TO ∞-LENGTH(TOKEN)];
S←"("&S[2 TO ∞]&")"&TOKEN;
ASKUSER(S);
GGTOKEN;
END;
ETOP1←E1←SPRCODE(PRSYM);
E0←NULL_RECORD;
FOR I←1 STEP 1 UNTIL NARGS DO
BEGIN "check each argument"
GGTOKEN;
IF PROC:ARGACCS[P][I] LAND #ARRTYP THEN
BEGIN "array argument found"
IF TOKENPTR=NULL_RECORD
THEN ERROR("Need array reference here")
ELSE IF SYMBOL:ACCESS[TOKENPTR]≠#ARRAY
THEN ERROR("Need array reference here")
ELSE IF ARRAYREC:#DIM[SYMBOL:OBJECT[TOKENPTR]]
≠PROC:ARGDIM[P][I]
THEN ERROR("array dimensions dont agree with declaration");
!!EXPR:BRO[E1]←(ETMP←NEW_EXPR(SYMBOL:OFFSET[TOKENPTR]));
E1←ETMP;
END "array argument found"
ELSE BEGIN
ETMP←EXP;
IF NOT(!!EXPR:TYPE[ETMP] LAND PROC:ARGTYPE[P][I])
THEN ERROR("expression type does not agree with declaration");
IF (PROC:ARGACCS[P][I]=0) OR
(PROC:ARGACCS[P][I] LAND #REFTYP) AND
(!!EXPR:OP[ETMP]≠XAGTVAL) AND
(!!EXPR:OP[ETMP]≠XGTVAL)
THEN
BEGIN "value"
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
!!EXPR:BRO[E1]←(ETMP←NEW_EXPR(#MINUS1));
E1←ETMP; STOKEN←TRUE;
END "value"
ELSE BEGIN "reference"
IF !!EXPR:OP[ETMP]=XGTVAL THEN
BEGIN "xgtval"
ETMP2←NEW_EXPR(!!EXPR:X1[ETMP]);
!!EXPR:BRO[E1]←ETMP2;
E1←ETMP2;
ETMP←!!EXPR:SON[ETMP];
##EL←##EL-2;
IF ETMP THEN
BEGIN
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
END;
END "xgtval"
ELSE IF !!EXPR:OP[ETMP]=XAGTVAL
THEN
BEGIN "xagtval"
ETMP2←NEW_EXPR(!!EXPR:X2[ETMP]);
!!EXPR:BRO[E1]←ETMP2;
E1←ETMP2;
##EL←##EL-1;
!!EXPR:OP[ETMP]←XPUSHINTI;
!!EXPR:#EL[ETMP]←2;
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
END "xagtval"
ELSE ERROR("Disastrous error");
STOKEN←TRUE;
END "reference";
END;
GGTOKEN;
IF I<NARGS
THEN IF TOKEN=")" THEN
BEGIN STRING S; INTEGER J; S←NULL;
IF I<(J←PROC:NON_DEFAULT_ARGS[P])
THEN ERROR("Need at least "&cvs(J)&" non-default arguments");
FOR J←I+1 STEP 1 UNTIL NARGS DO
S←S&","&PROC:DEFAULT_ARG[P][J];
S←S[1 TO ∞]&")";
$CLNSAVE←$CLNSAVE[1 TO ∞-1];
ASKUSER(S);
GGTOKEN;
END
ELSE IF TOKEN≠"," THEN
BEGIN ERROR("Need comma between arguments");
GGTOKEN;
END;
IF I=NARGS AND TOKEN≠")" THEN
ERROR("Need right paren after argument list");
END "check each argument";
EF←NEW_EXPR(XNOOP,NEW_EXPR(XNOOP,E0,ETOP1));
END "procedure with arguments";
!!EXPR:TYPE[EF]←SYMBOL:TYPE[PRSYM];
! newly inserted; GGTOKEN(FALSE); STOKEN←TRUE;
RETURN(EF);
END "prcode";
! checks that PRSYM points to a typed procedure ;
RECURSIVE RPTR(!!EXPR)PROCEDURE VPRCODE(RPTR(SYMBOL)PRSYM);
IF SYMBOL:TYPE[PRSYM]=#PR
THEN IF RETURN_NULL THEN BEGIN STOKEN←TRUE; RETURN(NULL_RECORD); END
ELSE ERROR(SYMBOL:PNAME[PRSYM]&" cannot return a value and cannot be used here")
ELSE RETURN(PRCODE(PRSYM));
! strcode,vmcode;
RPTR(!!EXPR)PROCEDURE STRCODE(STRING S; INTEGER FIRSTNUM(XPUSHQI));
BEGIN
RPTR(!!EXPR)E;
INTEGER I;
IPUSH(FIRSTNUM); ! push string immediate pcode ;
IPUSH((LENGTH(S)+2)DIV 2); ! push number of words ;
DO IPUSH(LOP(S)+ (I←LOP(S)) LSH 8) UNTIL I=0;
E←NEW_RECORD(!!EXPR);
##EL←##EL+EXPR$:#BODY[!!EXPR:EXPR$[E]←βEXPR$];
!!EXPR:TYPE[E]←#ST;
RETURN(E);
END;
RPTR(!!EXPR)PROCEDURE VMCODE;
BEGIN "vmcode"
RPTR(!!EXPR)E,E1; INTEGER I,FUNNO,NARGS;
WORD_READ("("); FUNNO←INTEGER_READ;
WORD_READ(","); NARGS←INTEGER_READ;
E←!!EXPRM(3,XVM,FUNNO,NARGS);
!!EXPR:TYPE[E]←#SC;
FOR I←1 STEP 1 UNTIL NARGS DO
BEGIN "first the value arguments"
INTEGER TYPECODE;
WORD_READ(",");
TYPECODE←INTEGER_READ;
WORD_READ(",");
GGTOKEN;
CASE TYPECODE OF
BEGIN
[0][2] IF #TOKEN=INT_TYPE OR #TOKEN=REAL_TYPE THEN
BEGIN INTEGER J; REAL R; INTEGER I1,I2;
RPTR(!!EXPR)E2;
R←REALSCAN(TOKEN,J); FLTOUT(R,I1,I2);
E2←!!EXPRM(2,I1,I2);
E1←!!EXPRM(2,TYPECODE,2);
!!EXPR:BRO[E1]←E2;
END
ELSE IF #TOKEN=ID_TYPE THEN
BEGIN IF SYMBOL:OFFSET[TOKENPTR]>'777 AND
SYMBOL:ACCESS[TOKENPTR]=#SIMPLE
AND SYMBOL:TYPE[TOKENPTR]=#SC
THEN E1←!!EXPRM(3,TYPECODE,0,SYMBOL:OFFSET[TOKENPTR])
ELSE ERROR("Need simple scalar id type here");
END
ELSE ERROR("Need scalar variable or constant here");
[4] IF TOKEN=dquote THEN
BEGIN STRING T; RPTR(!!EXPR) E2;
T←READTILL(dquote);
E2←STRCODE(T,TYPECODE);
E1←NEW_RECORD(!!EXPR);
!!EXPR:BRO[E1]←E2;
END
ELSE IF #TOKEN=ID_TYPE AND SYMBOL:TYPE[TOKENPTR]=#ST
AND SYMBOL:ACCESS[TOKENPTR]=#SIMPLE
AND SYMBOL:OFFSET[TOKENPTR]>'777
THEN E1←!!EXPRM(3,TYPECODE,0,SYMBOL:OFFSET[TOKENPTR])
ELSE ERROR("Need string constant or variabl here");
[6] IF #TOKEN=ID_TYPE AND SYMBOL:ACCESS[TOKENPTR]=#SIMPLE
AND SYMBOL:OFFSET[TOKENPTR]>'777
THEN E1←!!EXPRM(3,TYPECODE,0,SYMBOL:OFFSET[TOKENPTR])
ELSE ERROR("only simple variable allowed here");
ELSE ERROR("Only 0,2,4,6 now valid here")
END;
!!EXPR:SON[E1]←E;
E←E1;
END "first the value arguments";
WORD_READ(",");
NARGS←INTEGER_READ; ! now the reference arguments ;
E1←!!EXPRM(1,NARGS);
!!EXPR:SON[E1]←E;
E←E1;
FOR I←1 STEP 1 UNTIL NARGS DO
BEGIN INTEGER ARGTYP;
WORD_READ(",");
ARGTYP←INTEGER_READ;
WORD_READ(",");
GTOKEN;
IF #TOKEN=ID_TYPE AND SYMBOL:ACCESS[TOKENPTR]=#SIMPLE
AND SYMBOL:OFFSET[TOKENPTR]>'777
THEN E1←!!EXPRM(2,ARGTYP,SYMBOL:OFFSET[TOKENPTR])
ELSE ERROR("Need a local variable here");
!!EXPR:SON[E1]←E;
E←E1;
END;
WORD_READ(")");
GGTOKEN(FALSE);
!!EXPR:TYPE[E]←#SC;
RETURN(E);
END "vmcode";
! mkexpr,gtexpr,aref,idref,pref;
RPTR(EXPR$) PROCEDURE MKEXPR(INTEGER BUFSIZ;RPTR(!!EXPR)EE);
IF BUFSIZ=0 THEN RETURN(NULL_RECORD) ELSE
BEGIN "MKEXPR"
! routine for changing the tree structure form of the expression into
an integer array.
The integer array is returned in EXPR$:BODY;
! Caution : the bro field of the expression EE should be null ;
INTEGER ARRAY BUFFER[1:BUFSIZ]; INTEGER Q; RPTR(EXPR$) $$;
PROCEDURE PUSHBUFFER(INTEGER I);
BUFFER[Q←Q+1]←I;
PROCEDURE PUSHARRAY(RPTR(EXPR$)EPTR);
IF EPTR THEN BEGIN
ARRBLT(BUFFER[Q+1],EXPR$:BODY[EPTR][1],EXPR$:#BODY[EPTR]);
Q←Q+EXPR$:#BODY[EPTR]; END;
RECURSIVE PROCEDURE REDUCE(RPTR(!!EXPR)E);
BEGIN
RPTR(!!EXPR)E1;
E1←!!EXPR:SON[E];
WHILE E1≠NULL_RECORD DO
BEGIN REDUCE(E1);
E1←!!EXPR:BRO[E1];
END;
PUSHARRAY(!!EXPR:EXPR$[E]);
IF !!EXPR:#EL[E]=0 THEN RETURN;
PUSHBUFFER(!!EXPR:OP[E]);
IF !!EXPR:#EL[E]=1 THEN RETURN;
PUSHBUFFER(!!EXPR:X1[E]);
IF !!EXPR:#EL[E]=2 THEN RETURN;
PUSHBUFFER(!!EXPR:X2[E]);
END;
Q←0;
REDUCE(EE);
IF Q≠BUFSIZ THEN ERROR("something is wrong, the string of numbers"&CVS(Q)&" not equal to expected"&CVS(BUFSIZ));
RETURN_NULL←FALSE;
RETURN(αEXPR$(BUFFER,!!EXPR:TYPE[EE]));
END "MKEXPR";
RPTR(EXPR$)RECURSIVE PROCEDURE GTEXPR;
BEGIN "GTEXPR"
! driver for MKEXPR;
RPTR(!!EXPR)EE;
INTEGER ##ELSAVE,#EL;
##ELSAVE←##EL;
##EL←0;
GGTOKEN;
EE←EXP;
STOKEN←TRUE;
#EL←##EL;
##EL←##ELSAVE;
RETURN(MKEXPR(#EL,EE));
END "GTEXPR";
INTERNAL RPTR(EXPR$)PROCEDURE AREF(RPTR(SYMBOL)S;INTEGER OPERATION(XGTVAL));
BEGIN "AREF"
RPTR(!!EXPR)EE;
##EL←0;
EE←ARCODE(S,OPERATION);
RETURN(MKEXPR(##EL,EE));
END "AREF";
INTERNAL RPTR(EXPR$)PROCEDURE PREF(RPTR(SYMBOL)S);
BEGIN
RPTR(!!EXPR)EE;
##EL←0;
EE←PRCODE(S);
RETURN(MKEXPR(##EL,EE));
END;
! produces the EXPR$ record for references to variables
i.e. code to push the desired offset onto the stack ;
INTERNAL RPTR(EXPR$)PROCEDURE IDREF(REFERENCE RPTR(SYMBOL)S);
BEGIN "IDREF"
RPTR(!!EXPR)EE;
GGTOKEN;
IF TOKENPTR=NULL_RECORD THEN ERROR("Need identifier here")
ELSE S←TOKENPTR;
##EL←0;
EE←EXP;
IF !!EXPR:OP[EE]=XGTVAL THEN !!EXPR:OP[EE]←XPUSHOFFSET
ELSE IF !!EXPR:OP[EE]=XAGTVAL THEN !!EXPR:OP[EE]←XAPUSHOFFSET
ELSE ERROR("Need an identifier or array element here");
STOKEN←TRUE;
RETURN(MKEXPR(##EL,EE));
END "IDREF";
! buffer definitions, ipush,fpush,gpush,ppush,cpush;
INTEGER ARRAY $BUFFER[1:200];
INTEGER $BUFFERPTR;
! pushes integer J into the buffer ;
INTERNAL SIMPLE PROCEDURE IPUSH(INTEGER J);
$BUFFER[$BUFFERPTR←$BUFFERPTR+1]←J;
! pushes 11 representation of real value R into buffer ;
INTERNAL SIMPLE PROCEDURE FPUSH(REAL R);
BEGIN
FLTOUT(R,$BUFFER[$BUFFERPTR+1],$BUFFER[$BUFFERPTR+2]);
$BUFFERPTR←$BUFFERPTR+2;
END;
! pushes code to do a gtval ;
INTERNAL PROCEDURE GPUSH(RPTR(SYMBOL)S);
BEGIN INTEGER I;
IF SYMBOL:INDEX[S]>0
THEN FOR I←XAGTVAL,SYMBOL:INDEX[S],SYMBOL:OFFSET[S] DO IPUSH(I)
ELSE FOR I←XGTVAL,SYMBOL:OFFSET[S] DO IPUSH(I);
END;
INTERNAL PROCEDURE CPUSH(RPTR(SYMBOL)S);
BEGIN INTEGER I;
IF SYMBOL:INDEX[S]>0
THEN FOR I←XACHNGE,SYMBOL:INDEX[S],SYMBOL:OFFSET[S] DO IPUSH(I)
ELSE FOR I←XCHNGE,SYMBOL:OFFSET[S] DO IPUSH(I);
END;
INTERNAL PROCEDURE PPUSH(RPTR(SYMBOL)S);
IF SYMBOL:INDEX[S]>0 THEN
BEGIN IPUSH(XPUSHINTI);IPUSH(SYMBOL:INDEX[S]); END;
! αexpr$,βexpr$,nexpr,expr$11,expr$2,expr$off;
INTERNAL RPTR (EXPR$)PROCEDURE βEXPR$(INTEGER TYPE(0));
BEGIN
! creates a record EXPR$ with data from the buffer $BUFFER;
RPTR(EXPR$)EE; INTEGER ARRAY BUFF[1:$BUFFERPTR];
ARRBLT(BUFF[1],$BUFFER[1],$BUFFERPTR);
EE←MK_EXPR$;
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
EXPR$:#BODY[EE]←$BUFFERPTR;
EXPR$:TYPE[EE]←TYPE;
$BUFFERPTR←0;
RETURN(EE);
END;
INTERNAL RPTR(EXPR$)PROCEDURE NEXPR(INTEGER SIZE,ARG1);
BEGIN
! produces a record EXPR$ with #BODY=SIZE, and first element=ARG1;
INTEGER ARRAY BUFF[1:SIZE];
RPTR(EXPR$)EE;
BUFF[1]←ARG1;
EE←MK_EXPR$;
EXPR$:#BODY[EE]←SIZE;
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
RETURN(EE);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$1(INTEGER I(0));
RETURN(NEXPR(1,I));
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$2(INTEGER I(0),J(0));
BEGIN
RPTR(EXPR$)E;
E←NEXPR(2,I);
EXPR$:BODY[E][2]←J;
RETURN(E);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$3(INTEGER I(0),J(0),K(0));
BEGIN
RPTR(EXPR$)E;
E←NEXPR(3,I);
EXPR$:BODY[E][2]←J;
EXPR$:BODY[E][3]←K;
RETURN(E);
END;
INTERNAL INTEGER PROCEDURE EXPR$OFF(RPTR(EXPR$)ARRAY ARR; INTEGER I,J);
BEGIN
INTEGER K,K1;
K←1;
FOR K1←I STEP 1 UNTIL J DO IF ARR[K1] THEN K←K+EXPR$:#BODY[ARR[K1]];
RETURN(K);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$R(RPTR(SYMBOL)S);
IF SYMBOL:ACCESS[S]=#ARRAY_ELEMENT THEN
RETURN($APPEND(EXPR$G(S),EXPR$1(XRTVAL),SYMBOL:TYPE[S]))
ELSE
IF SYMBOL:INDEX[S]>0
THEN RETURN($APPEND(EXPR$2(XARTVAL,SYMBOL:INDEX[S]),
EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S]))
ELSE IF SYMBOL:OFFSET[S]<'1000
THEN RETURN($APPEND(EXPR$2(XGTVAL,SYMBOL:OFFSET[S]),
EXPR$1(XRTVAL),SYMBOL:TYPE[S]))
ELSE RETURN(EXPR$1(XNOOP));
INTERNAL RPTR(EXPR$) PROCEDURE EXPR$G(RPTR(SYMBOL)S);
IF SYMBOL:ACCESS[S]=#ARRAY_ELEMENT THEN
BEGIN
STRING S1; INTEGER I;
INTEGER ARRAY INDEX[1:5]; INTEGER IX;
S1←SYMBOL:PNAME[S];
DO I←LOP(S1) UNTIL I="[";
IX←0;
DO INDEX[IX←IX+1]←INTSCAN(S1,I) UNTIL I="]";
FOR I←IX STEP -1 UNTIL 1 DO BEGIN IPUSH(XPUSHINTI); IPUSH(INDEX[I]); END;
FOR I←XGTVAL,SYMBOL:OFFSET[S] DO IPUSH(I);
RETURN(βEXPR$(SYMBOL:TYPE[S]));
END ELSE
IF SYMBOL:INDEX[S]>0
THEN RETURN($APPEND(EXPR$2(XAGTVAL,SYMBOL:INDEX[S]),
EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S]))
ELSE IF SYMBOL:OFFSET[S]<'1000
THEN RETURN($APPEND(EXPR$1(XGTVAL),EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S]))
ELSE RETURN(EXPR$1(XNOOP));
INTERNAL RPTR (EXPR$) PROCEDURE αEXPR$(INTEGER ARRAY BUFFER;INTEGER #TYPE(0));
BEGIN
! creates a record EXPR$ with data the contents of BUFFER;
RPTR(EXPR$) EE; INTEGER I;
I←ARRINFO(BUFFER,2);
BEGIN
INTEGER ARRAY BUFF[1:I];
ARRTRAN(BUFF,BUFFER);
EE←MK_EXPR$;
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
EXPR$:#BODY[EE]←I;
END;
EXPR$:TYPE[EE]←#TYPE;
RETURN(EE);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$ID(RPTR(SYMBOL)S);
IF SYMBOL:ACCESS[S]≠#SIMPLE THEN ERROR("EXPR$ID must take simple argument")
ELSE IF SYMBOL:INDEX[S]>0 THEN
RETURN($APPEND(EXPR$2(XAPUSHOFFSET,SYMBOL:INDEX[S]),
EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S]))
ELSE IF SYMBOL:OFFSET[S]<'1000
THEN RETURN($APPEND(EXPR$1(XPUSHINTI),EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S]))
ELSE RETURN(EXPR$1(XNOOP));
! $append,$aappend;
INTERNAL RPTR(EXPR$) PROCEDURE $APPEND(RPTR(EXPR$)E1,E2; INTEGER TYPE(0));
BEGIN
RPTR(EXPR$)ARRAY TEMP[1:2];
TEMP[1]←E1;TEMP[2]←E2;
RETURN($AAPPEND(TEMP,TYPE));
END;
INTERNAL RPTR(EXPR$) PROCEDURE $AAPPEND(RPTR(EXPR$) ARRAY APTR;INTEGER TYPE(0));
BEGIN RPTR(EXPR$) PTR;
INTEGER LA,UA; LA←ARRINFO(APTR,1); UA←ARRINFO(APTR,2);
BEGIN INTEGER I,BSIZE,DSIZE; INTEGER ARRAY ASIZE,TSIZE[LA:UA];
RPTR(DBEXPR)ARRAY DPTR[LA:UA];
BSIZE←DSIZE←0;
FOR I←LA STEP 1 UNTIL UA DO
IF APTR[I] THEN BSIZE←BSIZE + (ASIZE[I]←EXPR$:#BODY[APTR[I]]);
IF BSIZE THEN
BEGIN "B"
INTEGER ARRAY BUFF[1:BSIZE]; INTEGER J1;
PTR←MK_EXPR$;J1←1;
FOR I←LA STEP 1 UNTIL UA DO
IF ASIZE[I]>0 THEN
BEGIN ARRBLT(BUFF[J1],EXPR$:BODY[APTR[I]][1],ASIZE[I]);
J1←J1+ASIZE[I];END;
MEMORY[LOCATION(BUFF)] ↔ MEMORY[LOCATION(EXPR$:BODY[PTR])];
EXPR$:#BODY[PTR]←BSIZE;
IF !DEBUG AND ¬!!DEBUGGING
THEN BEGIN
FOR I←LA STEP 1 UNTIL UA DO
IF APTR[I] THEN DSIZE←DSIZE + (TSIZE[I]←
DBEXPR:#COORD[(DPTR[I]←EXPR$:DBEXPR[APTR[I]])]);
IF DSIZE
THEN BEGIN "D"
INTEGER ARRAY TXTPOS,COORD[1:DSIZE];INTEGER J2;
RPTR(BLOCKREC)ARRAY BLOCK[1:DSIZE];RPTR(DBEXPR)DBR;
DBR←EXPR$:DBEXPR[PTR];J2←1;
FOR I←LA STEP 1 UNTIL UA DO
IF TSIZE[I]>0 THEN BEGIN
ARRBLT(TXTPOS[J2],DBEXPR:TXTPOS[DPTR[I]][1],TSIZE[I]);
ARRBLT(COORD[J2],DBEXPR:COORD[DPTR[I]][1],TSIZE[I]);
ARRBLT(BLOCK[J2],DBEXPR:BLOCK[DPTR[I]][1],TSIZE[I]);
J2←J2+TSIZE[I];
END;
MEMORY[LOCATION(TXTPOS)] ↔ MEMORY[LOCATION(DBEXPR:TXTPOS[DBR])];
MEMORY[LOCATION(COORD)] ↔ MEMORY[LOCATION(DBEXPR:COORD[DBR])];
MEMORY[LOCATION(BLOCK)] ↔ MEMORY[LOCATION(DBEXPR:BLOCK[DBR])];
DBEXPR:#COORD[DBR]←DSIZE;
END "D";
END;
END "B"
ELSE RETURN(NULL_RECORD);
END;
EXPR$:TYPE[PTR]←TYPE;
RETURN(PTR);
END;
! $$gtidref,$$gtanyexp,$$gtexpr,$$gtvexpr;
! returns code to push offset of id on stack - type must
be the same, else does not return, unless type=0 ;
INTERNAL RPTR(EXPR$) PROCEDURE $$GTIDREF(INTEGER TYPE;
REFERENCE RPTR(SYMBOL)SYM; STRING S);
BEGIN RPTR(EXPR$)E;
E←IDREF(SYM);
IF (TYPE=0) OR (EXPR$:TYPE[E]=TYPE) OR
(TYPE=#FR AND EXPR$:TYPE[E]=#TR) OR
(TYPE=#TR AND EXPR$:TYPE[E]=#FR)
THEN RETURN(E)
ELSE ERROR("Id type found does not agree with expected type in "&S);
END;
! returns an expr of indicated type or doesnt return at all;
INTERNAL RPTR(EXPR$) PROCEDURE $$GTANYEXP(STRING S;INTEGER TYPE);
BEGIN
RPTR(EXPR$)E; INTEGER TYPEF;
TYPEF←EXPR$:TYPE[E←$$GTEXPR];
IF (TYPEF=TYPE) OR (TYPEF=#TR AND TYPE=#FR) OR (TYPEF=#FR AND TYPE=#TR)
THEN RETURN(E)
ELSE IF TYPE≤#RT THEN ERROR("Need "&DTYPES[TYPE]&" expression for ",S)
ELSE ERROR("Need TRANS or FRAME expression for ",S);
END;
INTERNAL REAL PROCEDURE $GTREAL(STRING S);
BEGIN "$GTREAL"
RPTR(!!EXPR)EE; INTEGER ##ELSAVE,#EL;
##ELSAVE←##EL; ##EL←0;
GGTOKEN;
EE←EXP;
STOKEN←TRUE;
#EL←##EL;
##EL←##ELSAVE;
IF !!EXPR:CONST[EE] THEN RETURN(!!EXPR:RLVAL[EE]) ELSE
ERROR("Need real value for "&S);
END "$GTREAL";
INTERNAL RPTR(EXPR$) RECURSIVE PROCEDURE $$GTEXPR;
RETURN(GTEXPR);
INTERNAL RECURSIVE RPTR(EXPR$) PROCEDURE $$GTVEXPR;
RETURN($ELFEVAL(GTEXPR));
! $$gtxp2;
INTERNAL RPTR(EXPR$)PROCEDURE $$GTXP2;
BEGIN
RPTR(EXPR$)E;
RETURN_NULL←TRUE;
E←GTEXPR;
RETURN_NULL←FALSE;
RETURN(E);
END;
END "EXPR";